home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlfio.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  15.0 KB  |  753 lines
  1. /* xlfio.c - xlisp file i/o */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* external variables */
  10. extern LVAL k_direction,k_input,k_output;
  11. extern LVAL s_stdin,s_stdout,true;
  12. extern int xlfsize;
  13.  
  14. #ifdef BETTERIO
  15. extern LVAL k_io, k_elementtype;
  16. extern LVAL a_fixnum, a_char;
  17. #endif
  18.  
  19. /* forward declarations */
  20. #ifdef ANSI
  21. LVAL getstroutput(LVAL stream);
  22. LVAL printit(int pflag, int tflag);
  23. LVAL flatsize(int pflag);
  24. #else
  25. FORWARD LVAL getstroutput();
  26. FORWARD LVAL printit();
  27. FORWARD LVAL flatsize();
  28. #endif
  29.  
  30. /* xread - read an expression */
  31. LVAL xread()
  32. {
  33.     LVAL fptr,eof,val;
  34.  
  35.     /* get file pointer and eof value */
  36.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  37.     eof = (moreargs() ? xlgetarg() : NIL);
  38.     if (moreargs()) xlgetarg(); /* toss now unused argument */
  39.     xllastarg();
  40.  
  41.     /* read an expression */
  42.     if (!xlread(fptr,&val))
  43.         val = eof;
  44.  
  45.     /* return the expression */
  46.     return (val);
  47. }
  48.  
  49. /* xprint - built-in function 'print' */
  50. LVAL xprint()
  51. {
  52.     return (printit(TRUE,TRUE));
  53. }
  54.  
  55. /* xprin1 - built-in function 'prin1' */
  56. LVAL xprin1()
  57. {
  58.     return (printit(TRUE,FALSE));
  59. }
  60.  
  61. /* xprinc - built-in function princ */
  62. LVAL xprinc()
  63. {
  64.     return (printit(FALSE,FALSE));
  65. }
  66.  
  67. /* xterpri - terminate the current print line */
  68. LVAL xterpri()
  69. {
  70.     LVAL fptr;
  71.  
  72.     /* get file pointer */
  73.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  74.     xllastarg();
  75.  
  76.     /* terminate the print line and return nil */
  77.     xlterpri(fptr);
  78.     return (NIL);
  79. }
  80.  
  81. /* printit - common print function */
  82. LOCAL LVAL printit(pflag,tflag)
  83.   int pflag,tflag;
  84. {
  85.     LVAL fptr,val;
  86.  
  87.     /* get expression to print and file pointer */
  88.     val = xlgetarg();
  89.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  90.     xllastarg();
  91.  
  92.     /* print the value */
  93.     xlprint(fptr,val,pflag);
  94.  
  95.     /* terminate the print line if necessary */
  96.     if (tflag)
  97.         xlterpri(fptr);
  98.  
  99.     /* return the result */
  100.     return (val);
  101. }
  102.  
  103. /* xflatsize - compute the size of a printed representation using prin1 */
  104. LVAL xflatsize()
  105. {
  106.     return (flatsize(TRUE));
  107. }
  108.  
  109. /* xflatc - compute the size of a printed representation using princ */
  110. LVAL xflatc()
  111. {
  112.     return (flatsize(FALSE));
  113. }
  114.  
  115. /* flatsize - compute the size of a printed expression */
  116. LOCAL LVAL flatsize(pflag)
  117.   int pflag;
  118. {
  119.     LVAL val;
  120.  
  121.     /* get the expression */
  122.     val = xlgetarg();
  123.     xllastarg();
  124.  
  125.     /* print the value to compute its size */
  126.     xlfsize = 0;
  127.     xlprint(NIL,val,pflag);
  128.  
  129.     /* return the length of the expression */
  130.     return (cvfixnum((FIXTYPE)xlfsize));
  131. }
  132.  
  133. /* xopen - open a file */
  134. LVAL xopen()
  135. {
  136.     char *name,*mode;
  137.     FILE *fp;
  138.     LVAL dir;
  139. #ifdef BETTERIO
  140.     LVAL typ;
  141. #endif
  142.  
  143.     /* get the file name and direction */
  144.     name = (char *)getstring(xlgetfname());
  145.     if (!xlgetkeyarg(k_direction,&dir))
  146.         dir = k_input;
  147.  
  148. #ifdef BETTERIO
  149.     if (xlgetkeyarg(k_elementtype,&typ)) {
  150.         if (typ != a_fixnum && typ != a_char)
  151.             xlerror("illegal stream element type",typ);
  152.     }
  153.     else
  154.         typ = a_char;
  155. #endif
  156.  
  157.  
  158.  
  159.     /* get the mode */
  160.     if (dir == k_input)
  161.         mode = "r";
  162.     else if (dir == k_output)
  163.         mode = "w";
  164. #ifdef BETTERIO
  165.     else if (dir == k_io) {
  166.         mode = "r+";    /* try for existing file */
  167. #ifdef __ZTC__
  168.         if ((fp = ((typ == a_fixnum? &osbopen : &osaopen)(name,mode))) != 0)
  169.             return cvfile(fp);
  170. #else
  171.         if ((fp = ((typ == a_fixnum? osbopen : osaopen)(name,mode))) != 0)
  172.             return cvfile(fp);
  173. #endif
  174.         mode = "w+";    /* create new file */
  175.     }
  176. #endif
  177.     else
  178.         xlerror("bad direction",dir);
  179.  
  180.  
  181.  
  182.     /* try to open the file */
  183. #ifdef BETTERIO
  184. #ifdef __ZTC__
  185.     return (((fp = ((typ == a_fixnum ? &osbopen : &osaopen)(name,mode))) != 0)
  186.         ? cvfile(fp) : NIL);
  187. #else
  188.     return (((fp = ((typ == a_fixnum ? osbopen : osaopen)(name,mode))) != 0)
  189.         ? cvfile(fp) : NIL);
  190. #endif
  191. #else
  192.     return (((fp = osaopen(name,mode)) != 0) ? cvfile(fp) : NIL);
  193. #endif
  194. }
  195.  
  196. #ifdef BETTERIO
  197. /* xfileposition - get position of file stream */
  198. LVAL xfileposition()
  199. {
  200.     long i,j;
  201.     int t=0;
  202.     LVAL fptr;
  203.     FILE *fp;
  204.     /* get file pointer */
  205.     fp = getfile(fptr = xlgastream());
  206.  
  207.     /* make sure the file exists */
  208.     if (fp == NULL)
  209.         xlfail("file not open");
  210.  
  211. /* get current position, adjusting for posible "unget" */
  212.     j = ftell(fp) + (getsavech(fptr) ? -1L : 0L);
  213.  
  214.     if (moreargs()) { /* must be set position */
  215.         i = getfixnum(xlgafixnum());
  216.         xllastarg();
  217.         setsavech(fptr,'\0');    /* toss unget character, if any */
  218.         fptr->n_sflags = 0;        /* neither reading or writing currently */
  219.         if (i < 0 ||
  220.             (t=fseek(fp,i,SEEK_SET))!=0 ||
  221.             ftell(fp) != i) {
  222.             if (t) return NIL;
  223.             fseek(fp,j,SEEK_SET);
  224.             xlfail("position outside of file");
  225.         }
  226.         return true;
  227.     }
  228.  
  229.     return (j == -1L ? NIL : cvfixnum(j));
  230. }
  231.  
  232. /* xfilelength - returns length of file */
  233. LVAL xfilelength()
  234. {
  235.     FILE *fp;
  236.     long i,j;
  237.  
  238.     /* get file pointer */
  239.     fp = getfile(xlgastream());
  240.     xllastarg();
  241.  
  242.     /* make sure the file exists */
  243.     if (fp == NULL)
  244.         xlfail("file not open");
  245.  
  246.     if ((i=ftell(fp)) == -1L ||
  247.         fseek(fp,0L,SEEK_END) ||
  248.         (j = ftell(fp)) == -1L ||
  249.         fseek(fp,i,SEEK_SET)) {
  250.         return NIL;
  251.     }
  252.     
  253.     return cvfixnum(j);
  254. }
  255.  
  256.  
  257. #endif
  258.  
  259.  
  260. /* xclose - close a file */
  261. LVAL xclose()
  262. {
  263.     LVAL fptr;
  264.  
  265.     /* get file pointer */
  266.     fptr = xlgastream();
  267.     xllastarg();
  268.  
  269.     /* make sure the file exists */
  270.     if (getfile(fptr) == NULL)
  271.         xlfail("file not open");
  272.  
  273.     /* close the file */
  274.     osclose(getfile(fptr));
  275.     setfile(fptr,NULL);
  276.  
  277.     /* return nil */
  278.     return (NIL);
  279. }
  280.  
  281. /* xrdchar - read a character from a file */
  282. LVAL xrdchar()
  283. {
  284.     LVAL fptr;
  285.     int ch;
  286.  
  287.     /* get file pointer */
  288.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  289.     xllastarg();
  290.  
  291.     /* get character and check for eof */
  292.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
  293. }
  294.  
  295. /* xrdbyte - read a byte from a file */
  296. LVAL xrdbyte()
  297. {
  298.     LVAL fptr;
  299.     int ch;
  300.  
  301.     /* get file pointer */
  302.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  303.     xllastarg();
  304.  
  305.     /* get character and check for eof */
  306.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
  307. }
  308.  
  309. /* xpkchar - peek at a character from a file */
  310. LVAL xpkchar()
  311. {
  312.     LVAL flag,fptr;
  313.     int ch;
  314.  
  315.     /* peek flag and get file pointer */
  316.     flag = (moreargs() ? xlgetarg() : NIL);
  317.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  318.     xllastarg();
  319.  
  320.     /* skip leading white space and get a character */
  321.     if (flag)
  322.         while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  323.             xlgetc(fptr);
  324.     else
  325.         ch = xlpeek(fptr);
  326.  
  327.     /* return the character */
  328.     return (ch == EOF ? NIL : cvchar(ch));
  329. }
  330.  
  331. /* xwrchar - write a character to a file */
  332. LVAL xwrchar()
  333. {
  334.     LVAL fptr,chr;
  335.  
  336.     /* get the character and file pointer */
  337.     chr = xlgachar();
  338.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  339.     xllastarg();
  340.  
  341.     /* put character to the file */
  342.     xlputc(fptr,getchcode(chr));
  343.  
  344.     /* return the character */
  345.     return (chr);
  346. }
  347.  
  348. /* xwrbyte - write a byte to a file */
  349. LVAL xwrbyte()
  350. {
  351.     LVAL fptr,chr;
  352.  
  353.     /* get the byte and file pointer */
  354.     chr = xlgafixnum();
  355.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  356.     xllastarg();
  357.  
  358.     /* put byte to the file */
  359.     xlputc(fptr,(int)getfixnum(chr));
  360.  
  361.     /* return the character */
  362.     return (chr);
  363. }
  364.  
  365. /* xreadline - read a line from a file */
  366. LVAL xreadline()
  367. {
  368.     char buf[STRMAX+1],*p,*sptr;
  369.     LVAL fptr,str,newstr;
  370.     int len,blen,ch;
  371.  
  372.     /* protect some pointers */
  373.     xlsave1(str);
  374.  
  375.     /* get file pointer */
  376.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  377.     xllastarg();
  378.  
  379.     /* get character and check for eof */
  380.     len = blen = 0; p = buf;
  381.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
  382.  
  383.         /* check for buffer overflow */
  384.         if (blen >= STRMAX) {
  385.             newstr = newstring(len + STRMAX + 1);
  386.             sptr = getstring(newstr); *sptr = '\0';
  387.             if (str) strcat((char *)sptr,(char *)getstring(str));
  388.             *p = '\0'; strcat((char *)sptr,(char *)buf);
  389.             p = buf; blen = 0;
  390.             len += STRMAX;
  391.             str = newstr;
  392.         }
  393.  
  394.         /* store the character */
  395.         *p++ = ch; ++blen;
  396.     }
  397.  
  398.     /* check for end of file */
  399.     if (len == 0 && p == buf && ch == EOF) {
  400.         xlpop();
  401.         return (NIL);
  402.     }
  403.  
  404.     /* append the last substring */
  405.     if (str == NIL || blen) {
  406.         newstr = newstring(len + blen + 1);
  407.         sptr = getstring(newstr); *sptr = '\0';
  408.         if (str) strcat((char *)sptr,(char *)getstring(str));
  409.         *p = '\0'; strcat((char *)sptr,(char *)buf);
  410.         str = newstr;
  411.     }
  412.  
  413.     /* restore the stack */
  414.     xlpop();
  415.  
  416.     /* return the string */
  417.     return (str);
  418. }
  419.  
  420.  
  421. /* xmkstrinput - make a string input stream */
  422. LVAL xmkstrinput()
  423. {
  424.     int start,end,len,i;
  425.     char *str;
  426.     LVAL string,val;
  427.  
  428.     /* protect the return value */
  429.     xlsave1(val);
  430.     
  431.     /* get the string and length */
  432.     string = xlgastring();
  433.     str = getstring(string);
  434.     len = getslength(string) - 1;
  435.  
  436.     /* get the starting offset */
  437.     if (moreargs()) {
  438.         val = xlgafixnum();
  439.         start = (int)getfixnum(val);
  440.     }
  441.     else start = 0;
  442.  
  443.     /* get the ending offset */
  444.     if (moreargs()) {        /* TAA mod to allow NIL for end offset */
  445.         val = nextarg();
  446.         if (val == NIL) end = len;
  447.         else if (fixp(val)) end = (int)getfixnum(val);
  448.         else xlbadtype(val);
  449.     }
  450.     else end = len;
  451.     xllastarg();
  452.  
  453.     /* check the bounds */
  454.     if (start < 0 || start > len)
  455.         xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
  456.     if (end < 0 || end > len)
  457.         xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
  458.  
  459.     /* make the stream */
  460.     val = newustream();
  461.  
  462.     /* copy the substring into the stream */
  463.     for (i = start; i < end; ++i)
  464.         xlputc(val,str[i]);
  465.  
  466.     /* restore the stack */
  467.     xlpop();
  468.  
  469.     /* return the new stream */
  470.     return (val);
  471. }
  472.  
  473. /* xmkstroutput - make a string output stream */
  474. LVAL xmkstroutput()
  475. {
  476.     return (newustream());
  477. }
  478.  
  479. /* xgetstroutput - get output stream string */
  480. LVAL xgetstroutput()
  481. {
  482.     LVAL stream;
  483.     stream = xlgaustream();
  484.     xllastarg();
  485.     return (getstroutput(stream));
  486. }
  487.  
  488. /* xgetlstoutput - get output stream list */
  489. LVAL xgetlstoutput()
  490. {
  491.     LVAL stream,val;
  492.  
  493.     /* get the stream */
  494.     stream = xlgaustream();
  495.     xllastarg();
  496.  
  497.     /* get the output character list */
  498.     val = gethead(stream);
  499.  
  500.     /* empty the character list */
  501.     sethead(stream,NIL);
  502.     settail(stream,NIL);
  503.  
  504.     /* return the list */
  505.     return (val);
  506. }
  507. #ifdef ENHFORMAT
  508. /* decode prefix parameters and modifiers for a format directive */
  509. #ifdef ANSI
  510. static char *decode_pp(char *fmt, FIXTYPE *pp, int maxnpp, 
  511.                        int *npp, int *colon, int *atsign)
  512. #else
  513. LOCAL char *decode_pp( fmt, pp, maxnpp, npp, colon, atsign )
  514. char    *fmt;
  515. FIXTYPE    pp[];            /* prefix parameters */
  516. int        maxnpp;            /* maximum number of them */
  517. int        *npp;            /* actual number of them */
  518. int        *colon;            /* colon modifier given? */
  519. int        *atsign;        /* atsign modifier given? */
  520. #endif
  521. {
  522.     int gotpp = 0;        /* set to 1 when pp encountered */
  523.     
  524.     *npp = 0;
  525.     *colon = 0;
  526.     *atsign = 0;
  527.     pp[0] = 0;
  528.     do {
  529.         if( *fmt == ':' )
  530.             *colon = 1;
  531.         else if( *fmt == '@' )
  532.             *atsign = 1;
  533.         else if( *colon || *atsign )    /* nothing else may follow : or @ */
  534.            break;
  535.         else if( isdigit(*fmt) ) {
  536.             pp[*npp] = (pp[*npp] * 10) + (int)(*fmt - '0');
  537.             gotpp = 1;
  538.         }
  539.         else if( *fmt == ',' ) {
  540.             if( ++(*npp) >= maxnpp )
  541.                 xlerror("too many prefix parameters in format",cvstring(fmt));
  542.             pp[*npp] = 0;
  543.             gotpp = 1;
  544.         }
  545.         else if( *fmt == '\'' ) {
  546.             pp[*npp] = *(++fmt);
  547.             gotpp = 1;
  548.         }
  549.         else if( *fmt == 'v' || *fmt == 'V' ) {
  550.             pp[*npp] = getfixnum(xlgafixnum());
  551.             gotpp = 1;
  552.         }
  553.         else 
  554.             break;
  555.         fmt++;
  556.     } while( 1 );
  557.     *npp += gotpp;                /* fix up the count */
  558.     return fmt;
  559. }
  560.  
  561. #define mincol    pp[0]
  562. #define colinc    pp[1]
  563. #define minpad    pp[2]
  564. #define padchar pp[3]
  565.  
  566. /* opt_print - print a value using prefix parameter options */
  567. #ifdef ANSI
  568. static VOID opt_print(LVAL stream, LVAL val, int pflag, FIXTYPE *pp,
  569.                     int npp, int colon, int atsign)
  570. #else
  571. LOCAL VOID opt_print(stream,val,pflag,pp,npp,colon,atsign)
  572. LVAL    stream;
  573. LVAL    val;
  574. int        pflag;            /* quoting or not */
  575. FIXTYPE    pp[];            /* prefix parameters */
  576. int        npp;            /* number of them */
  577. int        colon;            /* colon modifier given? */
  578. int        atsign;            /* at-sign modifier given? */
  579. #endif
  580. {
  581.     int flatsize;
  582.     int i;
  583.     
  584.     switch( npp ) {        /* default values of prefix parameters */
  585.     case 0: mincol = 0;             /* see CLtL, page 387 */
  586.     case 1: colinc = 1;
  587.     case 2: minpad = 0;
  588.     case 3: padchar = ' ';
  589.     }
  590.     if( colinc <= 1 )
  591.             colinc = 1;
  592.     if( mincol < minpad )
  593.             mincol = minpad;
  594.  
  595.     if( mincol > 0 && atsign ) {        /* padding may be required on left */
  596.         xlfsize = 0;
  597.         xlprint(NIL,val,pflag);            /* print to get the flat size */
  598.         flatsize = xlfsize;
  599.         for( i = 0; i < minpad; flatsize++, i++ )
  600.             xlputc(stream,(int)padchar);
  601.         while( flatsize < mincol ) {
  602.             for( i = 0; i < colinc; i++ )
  603.                 xlputc(stream,(int)padchar);
  604.             flatsize += (int)colinc;
  605.         }
  606.     }
  607.  
  608.     xlfsize = 0;                /* print the value */
  609.     if( colon && val == NIL )
  610.         xlputstr(stream,"()");
  611.     else
  612.         xlprint(stream,val,pflag);
  613.     flatsize = xlfsize;
  614.     
  615.     if( mincol > 0 && !atsign ) {        /* padding required on right */
  616.         for( i = 0; i < minpad; flatsize++, i++ )
  617.             xlputc(stream,(int)padchar);
  618.         while( flatsize < mincol ) {
  619.             for( i = 0; i < colinc; i++ )
  620.                 xlputc(stream,(int)padchar);
  621.             flatsize += (int)colinc;
  622.         }
  623.     }
  624. }
  625.  
  626. #define MAXNPP    4
  627. #endif
  628.  
  629. /* xformat - formatted output function */
  630. LVAL xformat()
  631. {
  632.     char *fmt;
  633.     LVAL stream,val;
  634.     int ch;
  635. #ifdef ENHFORMAT
  636.     int npp;            /* number of prefix parameters */
  637.     FIXTYPE pp[MAXNPP];        /* list of prefix parameters */
  638.     int colon, atsign;    /* : and @ modifiers given? */
  639. #endif
  640.  
  641.     xlsave1(val);                        /* TAA fix */
  642.  
  643.     /* get the stream and format string */
  644.     stream = xlgetarg();
  645.     if (stream == NIL) {
  646.         val = stream = newustream();
  647.     }
  648.     else {
  649.         if (stream == true)
  650.             stream = getvalue(s_stdout);
  651.                                                                 /* fix from xlispbug.417 */
  652.         else if (streamp(stream)) {        /* copied from xlgetfile() */
  653.                 if (getfile(stream) == NULL)
  654.                         xlfail("file not open");
  655.         }
  656.         else if (!ustreamp(stream))
  657.                 xlbadtype(stream);
  658.         val = NIL;
  659.     }
  660.     fmt = getstring(xlgastring());
  661.  
  662.     /* process the format string */
  663.     while ((ch = *fmt++) != 0)
  664.         if (ch == '~') {
  665. #ifdef ENHFORMAT
  666.             fmt = decode_pp( fmt, pp, MAXNPP, &npp, &colon, &atsign );
  667. #endif
  668.             switch (*fmt++) {
  669.             case '\0':
  670.                 xlerror("expecting a format directive",cvstring(fmt-1));
  671.             case 'a': case 'A':
  672. #ifdef ENHFORMAT
  673.                 opt_print(stream,xlgetarg(),FALSE,pp,npp,colon,atsign);
  674. #else
  675.                 xlprint(stream,xlgetarg(),FALSE);
  676. #endif
  677.                 break;
  678.             case 's': case 'S':
  679. #ifdef ENHFORMAT
  680.                 opt_print(stream,xlgetarg(),TRUE,pp,npp,colon,atsign);
  681. #else
  682.                 xlprint(stream,xlgetarg(),TRUE);
  683. #endif
  684.                 break;
  685.             case '%':
  686. #ifdef ENHFORMAT
  687.                 if( pp[0] <= 0 ) pp[0] = 1;
  688.                 while( (pp[0])-- > 0 )
  689.                     xlterpri(stream);
  690. #else
  691.                 xlterpri(stream);
  692. #endif
  693.                 break;
  694.             case '~':
  695. #ifdef ENHFORMAT
  696.                 if( pp[0] <= 0 ) pp[0] = 1;
  697.                 while( (pp[0])-- > 0 )
  698.                     xlputc(stream,'~');
  699. #else
  700.                 xlputc(stream,'~');
  701. #endif
  702.                 break;
  703.             case '\n':
  704. #ifdef ENHFORMAT
  705.                 if( colon )
  706.                     break;
  707.                 if( atsign )
  708.                      xlterpri(stream);
  709. #endif
  710.                 while (*fmt && *fmt != '\n' && isspace(*fmt))
  711.                     ++fmt;
  712.                 break;
  713.             default:
  714.                 xlerror("unknown format directive",cvstring(fmt-1));
  715.             }
  716.         }
  717.         else
  718.             xlputc(stream,ch);
  719.         
  720.     /* unprotect */
  721.     xlpop();
  722.  
  723.     /* return the value */
  724.     return (val ? getstroutput(val) : NIL);
  725. }
  726.  
  727.  
  728. /* getstroutput - get the output stream string (internal) */
  729. LOCAL LVAL getstroutput(stream)
  730.   LVAL stream;
  731. {
  732.     char *str;
  733.     LVAL next,val;
  734.     int len,ch;
  735.  
  736.     /* compute the length of the stream */
  737.     for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
  738.         ++len;
  739.  
  740.     /* create a new string */
  741.     val = newstring(len + 1);
  742.     
  743.     /* copy the characters into the new string */
  744.     str = getstring(val);
  745.     while ((ch = xlgetc(stream)) != EOF)
  746.         *str++ = ch;
  747.     *str = '\0';
  748.  
  749.     /* return the string */
  750.     return (val);
  751. }
  752.  
  753.